{-# LANGUAGE OverloadedStrings #-}
module Main where

import Prelude hiding (id)
import Control.Arrow ((>>>), (>>^), (***), arr)
import Control.Category (id)
import Control.Monad (forM_)
import Data.Monoid (mempty, mconcat)
import Text.Pandoc (WriterOptions(..), defaultWriterOptions)
import System.FilePath

import Control.Arrow ((&&&))
import Data.List (isPrefixOf,isSuffixOf)
import qualified Data.Set as S

import Text.HTML.TagSoup

import Hakyll.Core.Compiler
import Hakyll.Web.Page


import Hakyll

main :: IO ()
main = hakyll $ do
  
    -- Compress CSS
    match "stylesheets/*" $ do
      route   idRoute
      compile compressCssCompiler
    
    -- Copy images
    match "images/*" $ do
      route   idRoute
      compile copyFileCompiler
    
    -- Copy javascripts
    match "javascripts/*" $ do
      route   idRoute
      compile copyFileCompiler

    -- Copy files
    match "files/*" $ do
      route   idRoute
      compile copyFileCompiler

    -- Copy files
    match "patches/*" $ do
      route   idRoute
      compile copyFileCompiler
          
    -- Render posts
    match "posts/*" $ do
      route   $ cleanURL
      compile $ pageCompiler
        >>> arr (renderDateField "date" "%Y-%m-%d" "Date unknown")
        >>> arr (setField "bodyclass" "post")
        >>> renderTagsField "prettytags" (fromCapture "tags/*")
        >>> addTeaser
        >>> applyTemplateCompiler "templates/post.html"
        >>> applyTemplateCompiler "templates/default.html"
        >>> relativizeUrlsCompiler
        >>> cleanUrlsCompiler

    -- Render posts list
    match "allposts.html" $ route cleanURL
    create "allposts.html" $ constA mempty
      >>> arr (setField "title" "All posts")
      >>> arr (setField "bodyclass" "postlist")
      >>> requireAllA "posts/*" addPostList
      >>> applyTemplateCompiler "templates/posts.html"
      >>> applyTemplateCompiler "templates/default.html"
      >>> relativizeUrlsCompiler
      >>> cleanUrlsCompiler

   -- Render some static pages
    forM_ ["index.markdown", "404.markdown"] $ \p ->
        match p $ do
            route   $ setExtension ".html"
            compile $ pageCompiler
                >>> arr (setField "title" "PIT mutation testing")
                >>> arr (setField "keywords" keywords)
                >>> arr (setField "description" "PIT - mutation testing for the real world")
                >>> applyTemplateCompiler "templates/default.html"
                >>> relativizeUrlsCompiler

    match "quickstart/*" $ do
      route   $ cleanURL
      compile $ pageCompiler 
        >>> applyTemplateCompiler "templates/default.html"
        >>> relativizeUrlsCompiler


    -- Index
    match "news.html" $ route cleanURL
    create "news.html" $ constA mempty
      >>> arr (setField "title" "PIT mutation testing")
      >>> arr (setField "keywords" keywords)
      >>> arr (setField "bodyclass" "default")
      >>> requireA "tags" (setFieldA "tagcloud" (renderTagCloud'))
      >>> requireAllA "posts/*" (id *** arr (take 10 . reverse . sortByBaseName) >>> addPostList )
      >>> applyTemplateCompiler "templates/news.html"
      >>> applyTemplateCompiler "templates/default.html"
      >>> relativizeUrlsCompiler
      >>> cleanUrlsCompiler
    
    -- Tags
    create "tags" $
      requireAll "posts/*" (\_ ps -> readTags ps :: Tags String)
    
    -- Add a tag list compiler for every tag
    match "tags/*" $ route $ cleanURL
    metaCompile $ require_ "tags"
      >>> arr tagsMap
      >>> arr (map (\(t, p) -> (tagIdentifier t, makeTagList t p)))
        
    -- Render RSS feed
    match "rss.xml" $ route cleanURL
    create "rss.xml" $ requireAll_ "posts/*" >>> renderRss feedConfiguration

            
    -- Read templates
    match "templates/*" $ compile templateCompiler
    
        -- Render some static pages
    --forM_ ["about.markdown", "404.markdown", "faq.markdown", "quickstart.markdown" ] $ \p ->
    match "*.markdown" $ do
      route   $ cleanURL
      compile $ pageCompiler 
        >>> arr (setField "keywords" keywords)
        >>> applyTemplateCompiler "templates/default.html"
        >>> relativizeUrlsCompiler


  where
    renderTagCloud' :: Compiler (Tags String) String
    renderTagCloud' = renderTagCloud tagIdentifier 100 120

    tagIdentifier :: String -> Identifier (Page String)
    tagIdentifier = fromCapture "tags/*"
    
      -- Common variables
    keywords = "pit"

-- | Auxiliary compiler: generate a post list from a list of given posts, and
-- add it to the current page under @$posts@
--
addPostList :: Compiler (Page String, [Page String]) (Page String)
addPostList = setFieldA "posts" $
    arr (reverse . sortByBaseName)
        >>> require "templates/postitem.html" (\p t -> map (applyTemplate t) p )
        >>> arr mconcat
        >>> arr pageBody
        

makeTagList :: String
            -> [Page String]
            -> Compiler () (Page String)
makeTagList tag posts =
    constA (mempty, posts)
        >>> addPostList
        >>> arr (setField "title" ("Posts tagged with &#8216;" ++ tag ++ "&#8217;"))
        >>> arr (setField "bodyclass" "postlist")
        >>> applyTemplateCompiler "templates/posts.html"
        >>> applyTemplateCompiler "templates/default.html"
        >>> cleanUrlsCompiler


-- | compiler to convert index.html to clean urls. Copy and pasted with minimal understanding from relativize url compiler code. Type signatures make no sense 
-- 
--
cleanUrlsCompiler :: Compiler (Page String) (Page String)
cleanUrlsCompiler = getRoute &&& id >>^ uncurry clean
  where
    clean Nothing = id
    clean (Just r) = fmap (cleanUrls $ indexConst r)

indexConst :: String -> String
indexConst any = "index.html"

-- | Relativize URL's in HTML
--
cleanUrls :: String  -- ^ string to strip
          -> String  -- ^ HTML to relativize
          -> String  -- ^ Resulting HTML

cleanUrls root = renderTags . map cleanUrls' . parseTags
  where
    cleanUrls' (TagOpen s a) = TagOpen s $ map (cleanUrlsAttrs root) a
    cleanUrls' x = x

-- | Relativize URL's in attributes
--
cleanUrlsAttrs :: String -- ^ string to strip
                  -> Attribute String  -- ^ Attribute to relativize
                  -> Attribute String  -- ^ Resulting attribute
cleanUrlsAttrs  root (key,value)  
    | key `S.member` urls && root `isSuffixOf` value  = (key, reverse (drop 10 (reverse value)) )
    | otherwise = (key, value)
  where
    urls = S.fromList ["src", "href"]


-- | Turns body of the page into the teaser

addTeaser :: Compiler (Page String) (Page String)
addTeaser = arr $
        copyBodyToField "teaser" >>> changeField "teaser" extractTeaser
    where
        extractTeaser :: String -> String
        extractTeaser [] = []
        extractTeaser xs@(x : xr)
            | "<!-- more -->" `isPrefixOf` xs = []
            | otherwise                       = x : extractTeaser xr

-- | Read a page, add default fields, substitute fields and render with Pandoc.
--
pitCompiler :: Compiler Resource (Page String)
pitCompiler = pageCompilerWith defaultHakyllParserState pitWriterOptions
        
-- | Custom HTML options for pandoc        
--
pitWriterOptions :: WriterOptions
pitWriterOptions = defaultHakyllWriterOptions
  { writerHtml5 = True
  , writerTableOfContents = True
  }

config :: HakyllConfiguration
config = defaultHakyllConfiguration
    { deployCommand = "rsync --checksum -ave _site/* /Volumes/pit-blog/pit" }
    
feedConfiguration :: FeedConfiguration
feedConfiguration = FeedConfiguration
    { feedTitle = "pit"
    , feedDescription = "PIT mutation testing"
    , feedAuthorName = "Henry Coles"
    , feedRoot = "http://pitest.org"
    }


-- custom routes
-----------------------------------------------------------------------

cleanURL :: Routes
cleanURL = gsubRoute "-" (const "/") `composeRoutes` (customRoute fileToDirectory)

fileToDirectory :: Identifier a -> FilePath
fileToDirectory = flip combine "index.html" . dropExtension . toFilePath

toIndex :: Routes
toIndex = customRoute fileToIndex

fileToIndex :: Identifier a -> FilePath
fileToIndex = flip combine "index.html" . dropFileName . toFilePath
